﻿<%
'
' 数据库操作，外部可以直接引用
' 要求：共同属性写入底层，这部分只是用于展现
' 函数命名：兼容旧系统,暂时没有统一

'取用户稿子数
Function getEssay(id)
	getEssay=conn.execute("select count(id) from 74hu_article where hu_author='"&id&"'")(0)
End Function
'显示公告
Function getReport
	Dim rss
	Set rss=Server.CreateObject("ADODB.Recordset")
	rss.open "select top 1 name from 74hu_gonggao order by id desc",conn,1,1
	If Not rss.eof Then
		getReport = "<a href="""&http_path&"report.asp?"&a_sid&""">"&nowml(getLeft(rss("name"),10))&"</a><br/>"
	End If
	rss.close
	Set rss=Nothing
End Function
'关闭数据库连接
Sub getClose()
	conn.close
	set conn=nothing
End Sub
'IP封锁
Sub ipLock(str)
	Dim IpArray,WhyIpLock,IpSQL,IpRS
	IpArray=split(str,".")
	IpSQL="SELECT iplock From 74hu_IpLock Where  "& _
	" (ipsame=4 and ip1="&Cint(IpArray(0))&" and ip2="&Cint(IpArray(1))&" and ip3="&Cint(IpArray(2))&" and ip4="&Cint(IpArray(3))&" )  "& _
	" Or (ipsame=3 and  ip1="&Cint(IpArray(0))&"  and  ip2="&Cint(IpArray(1))&"  and  ip3="&Cint(IpArray(2))&" )   "& _
	" Or (ipsame=2 and ip1="&Cint(IpArray(0))&" and ip2="&Cint(IpArray(1))&" ) Or (ipsame=1 and ip1="&Cint(IpArray(0))&" ) Order By ipid "
	Set IpRS=Conn.execute(IpSQL)
	If Not (IpRS.bof or IpRS.eof) Then
		WhyIpLock=split(IpRS("iplock"),"|")
		Response.write "你使用的IP段或IP地址已被封锁<br/>封锁原因:"&WhyIpLock(1)&"<br/>封锁时间:"&WhyIpLock(0)&""
		Response.End
		Set Conn=nothing
	End If
	Set IpRS=Nothing
End Sub
'事务经理 负责创建会话,日常维护
'	创建会话
'	流量统计
'	ip封锁
'	删除记录
Sub affairsManager
	checkUpdate()'系统维护检测
	Dim HU_users,HU_userip,HU_today,rsip,rsrr,rsnum
	'数据库连接
	Set Conn = Server.CreateObject("ADODB.Connection")
	' Conn.ConnectionString="DBQ="&server.mappath(""&db&"")&";DRIVER={Microsoft Access Driver (*.mdb)};pwd="
	Conn.ConnectionString="Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database PASSWORD=;Data Source="&Server.MapPath(""&db&"")
	Conn.open
	cache False'消除缓存
	'会话 -- 建立
	userArr(0)="0"		'ID
	userArr(1)="游客"&right(session.sessionID,6)	'name
	userArr(2)="-1"		'level
	userArr(3)=""		'生日
	sid=getFilter(bbssid,"")'获取会话
	newUser(sid)'构造会话
	a_sid=bbssid&"="&sid'生成会话
	'会话 -- 完成
	http_path=getServerPath()'生成当前地址
	HU_users=userArr(0)
	ipLock(User_ip)'ip封锁
	HU_userip=User_ip&"|"&left(user_agent,30)'为了尽可能避免相同IP的用户同时访问
	Set rsip = Server.CreateObject("ADODB.Recordset")
	rsip.open"select HU_Date,HU_Tod,HU_Today from 74hu_counter",conn,1,1
	HU_today=rsip("HU_Today")
	if rsip("HU_Date")<>time_date then'日行一次
		' HU_day=time_date-1
		Set rsrr=Server.CreateObject("ADODB.Recordset")
		rsrr.open "select num from 74hu_ad where id=1",conn,1,1
		If Not rsrr.eof Then
			rsnum=rsrr("num")
			If ifNum(rsnum)Then
				If rsnum>0 Then conn.Execute"delete * from 74hu_link where (hu_time<#"&dateadd("d", rsnum*-1, time_now)&"#)"'删除N天前的无连入友链
			End If
		End If
		rsrr.close
		Set rsrr=Nothing
		conn.Execute"delete * from 74hu_message where (savetime<#"&dateadd("d", bbsmsgkeep*-1, time_now)&"#)"'删除N天前的消息记录
		conn.Execute"Update 74hu_counter set HU_Today=0,HU_Browser=0,HU_Date='"&time_date&"',HU_Yays=HU_Yays+1,HU_Yesterday="&HU_today&" where id=1"'流量统计
		conn.Execute"delete from 74hu_iprr"
	else
		conn.Execute"Update 74hu_counter set HU_Browser=HU_Browser+1 where id=1"
		Set rsrr=Server.CreateObject("ADODB.Recordset")
		rsrr.open "select * from 74hu_iprr where HU_userip='"&HU_userip&"'",conn,1,3
		If rsrr.eof Then
		'在服务器繁忙时,相同IP用户同时刻访问会导致以下问题:
		'由于您和其他用户试图同时改变同一数据，导致 Microsoft Jet 数据库引擎停止进程。
		' If Not rsrr.eof Then
			' rsrr("logtime")=time_now
			' rsrr.update
		' Else
			rsrr.addnew
			rsrr("HU_Userip")=HU_userip
			rsrr("Users")=HU_users
			rsrr.update
			conn.Execute"Update 74hu_counter set HU_counter=HU_counter+1,HU_Today=HU_Today+1 where id=1"
		End If
		rsrr.close
		Set rsrr=Nothing
	end if
	conn.Execute"Update 74hu_counter set HU_Tod="&HU_today&" where "&rsip("HU_Tod")&"<"&HU_today&" and id=1"
	conn.Execute"Update 74hu_counter set HU_Browsers=HU_Browsers+1 where id=1"
	rsip.close
	set rsip=nothing
End Sub
'生成唯一的sid值，使用时要引用md5以及建立连接
Function getOnlySid()
	Dim tmp_,count_
	tmp_=md5(md5(hu_randomize,16),32)
	count_=conn.Execute("select count(id) from 74hu_user where sid='"&tmp_&"'")(0)
	if count_<>0 then tmp_=getOnlySid()
	getOnlySid=tmp_
End Function
''随机广告,定义数目
Function getAD(typeID, num)
	If typeID<>1 And typeID<>2 And typeID<>3 And typeID<>4 And typeID<>5 Then getAD="":Exit Function
	Dim rsads,newad
	Set rsads=Server.CreateObject("Adodb.Recordset")
	Randomize
	rsads.open"select top "&num&" g.id,g.name from 74hu_gogo g,74hu_control c where c.ads"&typeID&"=1 and g.typeID="&typeID&" order by rnd(-(g.id+" & rnd() & ")) ",conn,1,1
	While Not rsads.EOF
		newad = newad& "<a href='"&http_path&"?aid=url&amp;id="&rsads("id")&"&amp;"&a_sid&"'>"&noubb(rsads("name"))&"</a><br/>"
		rsads.MoveNext
	Wend
	rsads.close
	Set rsads=Nothing
	getAD=newad
End Function
'定义广告
Function adsetkf(adnum)
	Dim rsadset
	Set rsadset=Server.CreateObject("Adodb.Recordset")
	rsadset.open"select "&adnum&" from 74hu_control where ID=1",conn,1,1
	If Not rsadset.eof Then
		adsetkf=rsadset(adnum)
	End If
	rsadset.close
	Set rsadset=nothing
End Function
'生成文章链接
Function getArticle(relid,num,typeid)
	Dim str,rs,sql
	If relid<>0 Then str="and classid in("&relid&")"
	sql="select top "&num&" id,title from 74hu_article where classid<>0 "&str&" order by "
	Select Case typeid
	Case 1:'最新文章
		sql=sql&"id desc"
	Case 2:''最热文章
		sql=sql&"hit*100000+id desc"
	Case 3:''随机文章
		Randomize()
		sql=sql&"rnd(-(id*"&rnd()&"))"
	End Select
	str=""
	Set rs=Server.CreateObject("ADODB.Recordset")
	rs.open sql,conn,1,1
	If Not rs.eof Then
		If hu_getLeft Then
			While Not rs.eof
				str=str&"<a href="""&http_path&"article.asp?id="&rs("id")&"&amp;"&a_sid&""">"&getLeft(noubb(rs("title")),numtitle)&"</a><br/>"
				rs.MoveNext
			Wend
		Else
			While Not rs.eof
				str=str&"<a href="""&http_path&"article.asp?id="&rs("id")&"&amp;"&a_sid&""">"&noubb(rs("title"))&"</a><br/>"
				rs.MoveNext
			Wend
		End If
	Else
		str="还没有文章！<br/>"
	End If
	rs.close
	Set rs=Nothing
	getArticle=str
End Function
'最新文章
Function newtitle(num,relid)
	w getArticle(relid,num,1)
End Function
'最热文章
Function hottitle(num,relid)
	w getArticle(relid,num,2)
End Function
'随机文章
Function wendtitle(num,relid)
	w getArticle(relid,num,3)
End Function
'最新帖子
Function newpost(num,relid)
	Dim gettest,rs1
	If relid<>0 Then gettest="where classid in("&relid&")"
	Set rs1=Server.CreateObject("Adodb.Recordset")
	rs1.open"select top "&num&" id,title from 74hu_topic "&gettest&" order by id desc",conn,1,1
	If rs1.eof Then
		w ("还没有帖子！<br/>")
	Else
		' rs1.Move(0)
		While Not rs1.eof
			If hu_getLeft Then
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs1("id")&"&amp;"&a_sid&""">"&getLeft(noubb(rs1("title")),numtitle)&"</a><br/>"
			Else
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs1("id")&"&amp;"&a_sid&""">"&noubb(rs1("title"))&"</a><br/>"
			End If
			rs1.MoveNext
		Wend
	End If
	rs1.close
	Set rs1=Nothing
End Function
'最热帖子
Function hotpost(num,relid)
	dim rs2,gettest
	If relid<>0 Then gettest="where classid in("&relid&")"
	Set rs2 = Server.CreateObject("Adodb.Recordset")
	rs2.open"select top "&num&" id,title from 74hu_topic "&gettest&" order by hit*100000+id desc",conn,1,1
	If rs2.eof Then
		w ("还没有帖子！<br/>")
	Else
		' rs2.Move(0)
		While Not rs2.eof
			If hu_getLeft Then
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs2("id")&"&amp;"&a_sid&""">"&getLeft(noubb(rs2("title")),numtitle)&"</a><br/>"
			Else
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs2("id")&"&amp;"&a_sid&""">"&noubb(rs2("title"))&"</a><br/>"
			End If
			rs2.MoveNext
		Wend
	End If
	rs2.close
	Set rs2=Nothing
End Function
'随机帖子
Function wendpost(num,relid)
	Dim rs3,gettest
	If relid<>0 Then gettest="where classid in("&relid&")"
	Set rs3=Server.CreateObject("Adodb.Recordset")
	Randomize
	rs3.open"select top "&num&" id,title from 74hu_topic "&gettest&" order by rnd(-(id*"&rnd()&")) ",conn,1,1
	If rs3.eof Then
		w ("还没有帖子！<br/>")
	Else
		' rs3.Move(0)
		While Not rs3.eof
			If hu_getLeft Then
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs3("id")&"&amp;"&a_sid&""">"&getLeft(noubb(rs3("title")),numtitle)&"</a><br/>"
			Else
				w "<a href="""&http_path&"bbs_posts.asp?id="&rs3("id")&"&amp;"&a_sid&""">"&noubb(rs3("title"))&"</a><br/>"
			End If
			rs3.MoveNext
		Wend
	End If
	rs3.close
	Set rs3=Nothing
End Function
'动态友链
Function toplink(max,num)
	Dim Rslc,aaa
	If Trim(max)="" or IsNumeric(max)=False Then max=8
	If Trim(num)="" or IsNumeric(num)=False Then num=4
	Set Rslc = Server.CreateObject("ADODB.Recordset")
	Sqlink = "select top "&max&" id,namt from 74hu_link Where active =0 and del=0 order by HU_time desc"
	Rslc.open Sqlink, conn, 1, 1
	If Rslc.EOF Then toplink = "暂无友链！<br/>"
	aaa = 1
	Do While ((Not Rslc.EOF) And aaa <= max)
		toplink = toplink & "<a href="""&http_path&"link.asp?id=" & Rslc("id") & "&amp;act=view&amp;"&a_sid&""">" & noubb(Rslc("namt")) & "</a> "
		If aaa Mod num = 0 And aaa <> Rslc.RecordCount Then toplink = toplink & "<br/>"
		Rslc.MoveNext
		aaa = aaa + 1
	Loop
	Rslc.Close
	Set Rslc = Nothing
End Function
'构造会话,会员实例
Sub newUser(str)
	Dim rs_,sql_,url_
	If IsNull(str) Or str="" Then str="74hujz_null"
	Set rs_=Server.CreateObject("ADODB.Recordset")
	sql_="select id,name,logtime,logip,hu_level,birthday from 74hu_user where sid='"&str&"'"
	rs_.open sql_,conn,1,3
	If Not rs_.eof Then
		If User_ip=rs_("logip") Or bbsip=0 Then'IP异常要重新登录
			userArr(0)=rs_("id")
			userArr(1)=rs_("name")
			userArr(2)=rs_("hu_level")
			userArr(3)=rs_("birthday")
			rs_("logip")=User_ip
			rs_("logtime")=time_now'更新在线时间
			rs_.update()
		Else
			url_=forBackUrl
			If hu_style Then
				getHead "</head><body><div class=""main"">", 2
			Else
				getHead "</head>", 1
			End If
			rupt "页面出错","检测IP异常,请重新登录！<br/><a href="""&http_path&"bbs_login.asp?_u="&url_&""">现在登录</a> "&_
				"<a href="""&http_path&"bbs_reg.asp?_u="&url_&""">还没注册？</a>"
		End If
	End If
	rs_.close
	Set rs_=Nothing
End Sub
'验证好友关系
'-1 : 不是好友,以对方信息为准
'0  : 等待对方审核,还不是好友
'1  : 好友
'2  : 黑名单
Function getFriendship(id)
	Dim usr
	usr=userArr(0)'取当前会员ID
	If id=0 Or usr=0 Or id=usr Then getFriendship=-1:Exit Function
	Dim rs_,sql_
	Set rs_=Server.CreateObject("ADODB.Recordset")
	sql_ = "select state from 74hu_friend where fid="&usr&" and uid="&id&""'以对方为准
	rs_.open sql_,conn,1,1
	If Not rs_.eof Then
		getFriendship = rs_("state")
	Else
		getFriendship = -1
	End If
	rs_.close
	Set rs_=Nothing
End Function
'获取用户名
Function getUserName(id)
	Dim rs_,sql_
	Set rs_=Server.CreateObject("ADODB.Recordset")
	sql_ = "select name from 74hu_user where id="&id
	rs_.open sql_,conn,1,1
	If Not rs_.eof Then
		getUserName=rs_("name")
	Else
		getUserName=""
	End If
	rs_.close
	Set rs_=Nothing
End Function
'在线会员
Function getOnline(str)
	If str="1" or str="2" Then
		str="and sex="&str
	Else
		str=""
	End If
	Dim count_
	count_=conn.execute("select count(id) from 74hu_user where (logtime>#"&dateadd("n", -20, time_now)&"#) "&str)(0)
	getOnline=count_
End Function
'检测有没有未读信息
Function getUserMsgCount(id)
	Dim count_
	count_=conn.execute("select count(id) from 74hu_message where state=0 and flag<>"&id&" and receive="&id)(0)
	getUserMsgCount=count_
End Function
'好友申请列表数
Function getUserFriendApplyCount(id)
	Dim count_
	count_=conn.execute("select count(id) from 74hu_friend where state=0 and uid="&id)(0)
	getUserFriendApplyCount=count_
End Function
'实现设计中心页面
Sub classPage(id)
	Dim rs_
	Set rs_ = Server.CreateObject("adodb.recordset")
	rs_.open "select lx,class,wmltxt,relid,br,num,classid from 74hu_class where parent="&id&" and pid>0 order by pid asc,classid desc", conn, 1, 1
	If rs_.eOF Then
		w "网站建设中..<br/>"
	else
		' rs_.Move (0)
		Do While Not rs_.eOF
			Select Case rs_("lx")
				Case 2 w ubbcode(rs_("wmltxt"))
				Case 9 w wmlcode(rs_("wmltxt"))
				Case 8 w getAD(1,1)
				Case 10 Call newtitle(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 11 Call hottitle(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 12 Call wendtitle(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 13 Call newpost(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 14 Call hotpost(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 15 Call wendpost(rs_("num"), rs_("relid")& rs_("wmltxt"))
				Case 0 w "<a href="""&http_path&"class.asp?id="&rs_("classid")&"&amp;"&a_sid&""">"&nowml(rs_("class"))&"</a>"
				Case 1 w "<a href="""&http_path&"list.asp?id="&rs_("relid")&"&amp;"&a_sid&""">"&nowml(rs_("class"))&"</a>"
				Case 3 w "<a href="""&http_path&"bbs_topic.asp?id="&rs_("classid")&"&amp;"&a_sid&""">"&nowml(rs_("class"))&"</a>"
				Case 19 w getSearchXml
				Case 20 w getWorldComment(rs_("num"))
			End Select
			If rs_("br") = "1" Then w "<br/>"
			rs_.MoveNext
		Loop
	end If
	rs_.close
	Set rs_ = nothing
End Sub
'检查文章是否重复,seo需要
Function ifArticleRepeat(title)
	ifArticleRepeat=False
	If 0<>conn.execute("select count(id) from 74hu_article where title='"&title&"'")(0) Then ifArticleRepeat=True
End Function
'群聊功能
Function getWorldComment(num)
	dim rs,sql,str,count,tid
	If num<=0 Then num=3
	count=conn.execute("select count(id) from 74hu_pl where smsid=0")(0)
	sql="select top "&num&" pl from 74hu_pl where smsid=0 order by id desc"
	tid=count
	Set rs=Server.CreateObject("ADODB.Recordset")
	rs.open sql,conn,1,1
	if Not rs.eof Then
		while Not rs.eof
			str=str&""&tid&"楼."&getLeft(noubb(noad(rs("pl"))),10)&"<br/>"
			rs.movenext
			tid=tid-1
		Wend
		str=str&"<a href='"&http_path&"discuss.asp?id=0&amp;"&a_sid&"'>网友群聊("&count&")</a>"
	Else
		str="<a href='"&http_path&"discuss.asp?id=0&amp;"&a_sid&"'>快来群聊吧</a>"
	end if
	getWorldComment=str&"<br/>"&getWorldCommentXml
End Function
%>